home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0035_TEXTFADE.PAS.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  4KB  |  171 lines
  1. {
  2. I attempted to Write a Unit For Text FADING, but I don't have it all down
  3. right...  If any one wants to play With the Unit and perfect it I would not
  4. mind!  My problem is that I do not know the correct values to change in the
  5. color register For the affect of a fade.  Once all the values are 0 the screen
  6. is black, but on the way there the screen gets some strange colors... Also, if
  7. you know how to change the colors, you can implement your own custom colors for
  8. Text mode.  I think 256 different colors, but only 16 at a time. (I am only
  9. guessing at that last part).   The FADEOUT and FADEIN does work here, but it
  10. goes through some strange colors on the way!
  11.  
  12. Robert
  13. }
  14.  
  15. Unit TextFade; {attempt For implementing Text fading}
  16. { only works For VGA or SVGA as Far as I know! }
  17.  
  18. Interface
  19.  
  20. Uses Dos, Crt;
  21.  
  22. Type
  23.   ColorRegister =
  24.   Record
  25.     Red      : Byte;
  26.     Green    : Byte;
  27.     Blue     : Byte;
  28.   end;
  29.  
  30.   ColorRegisterArray    = Array[0..255] of ColorRegister;
  31.   ColorRegisterArrayPtr = ^ColorRegisterArray;
  32.  
  33. Var
  34.   SaveCRAp      : ColorRegisterArrayPtr;
  35.  
  36. Procedure SaveColorRegister(Var CRAp : ColorRegisterArrayPtr);
  37. { given a color register Array ptr, this will save the current }
  38. { values so you can restore from them later...                 }
  39.  
  40. Procedure SetColorRegister(Var CRAp : ColorRegisterArrayPtr);
  41. { when you adjust the values of a color register set, this     }
  42. { Procedure will make put the new values into memory           }
  43.  
  44. Procedure FadeOut(MS_Delay : Integer);
  45. { using the global Variable 'SaveCRAp', this will fade the Text}
  46. { screen out till all the values in the color register Array   }
  47. { ptr are 0                                                    }
  48.  
  49. Procedure FadeIn(MS_Delay : Integer);
  50. { once again using the global Variable 'SaveCRAp', this will   }
  51. { fade the screen back in till all values of the current color }
  52. { register Array ptr are equal to 'SaveCRAp'                   }
  53.  
  54. Implementation
  55.  
  56. Procedure Abort(Msg : String);
  57. begin
  58.   Writeln(Msg);
  59.   Halt(1);
  60. end;
  61.  
  62. Procedure SaveColorRegister(Var CRAp : ColorRegisterArrayPtr);
  63. Var
  64.   R : Registers;
  65. begin
  66.   With R Do
  67.   begin
  68.     ah := $10;
  69.     al := $17;
  70.     bx := $00;
  71.     cx := 256;
  72.     es := Seg(crap^);
  73.     dx := Ofs(crap^);
  74.   end;
  75.   Intr($10,r);
  76. end;
  77.  
  78. Procedure SetColorRegister(Var CRAp : ColorREgisterArrayPtr);
  79. Var
  80.   R : Registers;
  81. begin
  82.   With R Do
  83.   begin
  84.     ah := $10;
  85.     al := $12;
  86.     bx := $00;
  87.     cx := 256;
  88.     es := Seg(crap^);
  89.     dx := Ofs(crap^);
  90.   end;
  91.   Intr($10,r);
  92. end;
  93.  
  94. Procedure FadeOut(MS_Delay : Integer);
  95. Var
  96.   NewCRAp : ColorRegisterArrayPtr;
  97.   W       : Word;
  98.   T       : Word;
  99. begin
  100.   New(NewCRAp);
  101.   If NewCRAp = NIL Then
  102.     Abort('Not Enough Memory');
  103.   NewCrap^ := SaveCrap^;
  104.   For T := 1 to 63 Do
  105.   begin
  106.     For W := 0 to 255 Do
  107.     With NewCRAp^[w] Do
  108.     If Red + Green + Blue > 0 Then
  109.     begin
  110.       Dec(Red);
  111.       Dec(Green);
  112.       Dec(Blue);
  113.     end;
  114.     SetColorRegister(NewCRAp);
  115.     Delay(MS_Delay);
  116.   end;
  117. end;
  118.  
  119. Procedure FadeIn(MS_Delay : Integer);
  120. Var
  121.   NewCRAp : ColorRegisterArrayPtr;
  122.   W       : Word;
  123.   T       : Word;
  124. begin
  125.   New(NewCRAp);
  126.   If NewCRAp = Nil Then
  127.     Abort('Not Enough Memory');
  128.   FillChar(NewCRAp^,SizeOf(NewCRAp^),0);
  129.   For T := 1 to 63 Do
  130.   { The values in the color register are not higher than 63 }
  131.   begin
  132.     For W := 0 to 255 Do
  133.     If SaveCRAp^[w].Red + SaveCRAp^[w].Green + SaveCRAp^[w].Red > 0 Then
  134.     begin
  135.       If NewCRAp^[w].Red   < SaveCRAp^[w].Red Then
  136.         Inc(NewCRAp^[w].Red);
  137.       If NewCRAp^[w].Green < SaveCRAp^[w].Green Then
  138.         Inc(NewCRAp^[w].Green);
  139.       If NewCRAp^[w].Blue  < SaveCRAp^[w].Blue Then
  140.         Inc(NewCRAp^[w].Blue);
  141.     end;
  142.     SetColorRegister(NewCRAp);
  143.     Delay(MS_Delay);
  144.   end;
  145. end;
  146.  
  147.  
  148. begin
  149.   New(SaveCRAp);
  150.   {get memory For the Pointer}
  151.   If SaveCRAp = Nil Then Abort('Not Enough Memory');
  152.   {make sure it actually got some memory}
  153.   SaveColorRegister(SaveCRAp);
  154.   {save the current values into SaveCRAp}
  155. end.
  156.  
  157. ---------------8<-----cut here------>8---------
  158.  
  159. Here is a demo of how to use it...
  160.  
  161.  
  162. Uses TextFADE;
  163.  
  164. begin
  165.    FADEOUT(10);
  166.    WriteLN(' HOW DOES THIS LOOK');
  167.    FADEIN(10);
  168.    Dispose(SaveCRAp);
  169.    {I just Realized I never got rid of this Pointer before!}
  170. end.
  171.